home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Fred (editor) utilities.sea / Fred (editor) utilities / autosave.lisp next >
Encoding:
Text File  |  1993-02-26  |  6.3 KB  |  157 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;-----------------------------------------------------------------------------
  3. ;;;  A U T O S A V E
  4. ;;;-----------------------------------------------------------------------------
  5. #|
  6.  
  7. Most of the original code is from a posting by:
  8.  
  9. From: Bill St. Clair <bill@cambridge.apple.com>
  10. Subject: Re: Autosave Feature (and the lack thereof) 
  11. Date: Wed, 26 Jun 91 17:05:09 -0400
  12.  
  13. Modifications by Kemi Jona (jona@ils.nwu.edu) Feb/March 1992:
  14.  
  15. - now is more like EMACS autosave
  16. - files autosaved with an appended ~
  17. - autosave files deleted when original file is saved
  18. - prompt when opening up a file with a newer autosave file
  19.  
  20. Note:  this file defines an AROUND method for FRED-WINDOW's
  21. INITIALIZE-INSTANCE and and AFTER method for FRED-WINDOW's WINDOW-SAVE.
  22. If either of these methods are already defined, you will be
  23. prompted before they get clobbered by this file.
  24.  
  25. I like this method of autosaving because it doesn't clobber your
  26. original file.  This allows you to revert to a saved version if you
  27. break something and want the old version back, but still have the
  28. security of having your worked saved periodically.
  29.  
  30. Under normal operation, there shouldn't be any leftover autosave
  31. files (except if you crash, in which case you want them!).  If for some reason 
  32. there are, I've included a function to clean them out of a directory. 
  33. The function is called AUTOSAVE-CLEAN-DIRECTORY.
  34.  
  35. Please post enhancements to cambridge.apple.com, /pub/MCL2/contrib/.
  36. Some things that need work: erase autosave file when reverting window
  37. or doing a Save as.
  38.  
  39. To use: save this file as autosave.lisp in the library folder and put the following
  40. in your init.lisp file:
  41.  
  42. (load "ccl:library;autosave")
  43. (set-auto-save-period 5)                      ; or whatever you want
  44.  
  45. The argument to SET-AUTO-SAVE-PERIOD is the number of minutes between autosaves.
  46.  
  47. |#
  48.  
  49. (in-package :ccl)
  50.  
  51. (export '(set-auto-save-period autosave-clean-directory))
  52.  
  53. (defvar *next-auto-save-time* nil)
  54. (defvar *auto-save-period* nil)
  55.  
  56. (defun ticks () (#_TickCount))
  57.  
  58. ; NIL will turn off autosaving
  59. (defun set-auto-save-period (minutes)
  60.   (if minutes
  61.     (progn
  62.       (setq *auto-save-period* (round (* minutes 3600))) 
  63.       (without-interrupts
  64.        (setq *next-auto-save-time*
  65.              (min (or *next-auto-save-time* most-positive-fixnum)       ; 8 year max
  66.                   (+ (ticks) *auto-save-period*)))))
  67.     (setq *auto-save-period* nil
  68.           *next-auto-save-time* nil)))
  69.  
  70.  
  71. ;;; this version does like emacs and autosaves the file under a
  72. ;;; different name (ie with an appended ~) 
  73. ;;; modified by Kemi Jona, 2/2
  74.  
  75. (defun do-auto-save ()
  76.   (with-cursor *watch-cursor*
  77.     (#_ShowCursor)
  78.     (map-windows #'(lambda (win)
  79.                      (when (and (not (typep win 'listener))
  80.                                 (slot-value win 'my-file-name)
  81.                                 (window-needs-saving-p win))
  82.                        (set-mini-buffer win "Auto-saving...")
  83.                        (catch-cancel 
  84.                         (buffer-write-file
  85.                          (fred-buffer win) 
  86.                          (pathname (concatenate 'string 
  87.                                                 (namestring (slot-value win 'my-file-name))
  88.                                                 "~"))
  89.                          :if-exists :overwrite))
  90.                        (set-mini-buffer win "Auto-saving...done")))
  91.                  :class 'fred-window)))
  92.  
  93. (defun maybe-do-auto-save ()
  94.   (let ((time *next-auto-save-time*)
  95.         ticks)
  96.     (when (and time (>= (setq ticks (ticks)) time))
  97.         (setq *next-auto-save-time* (+ ticks *auto-save-period*))
  98.         (do-auto-save)))
  99.   ; NIL tells event-dispatch that we are'nt handling the event
  100.   nil)
  101.  
  102. (push 'maybe-do-auto-save *eventhook*)
  103.  
  104. (defun autosave-clean-directory ()
  105.   (let ((dir (pathname (directory-namestring (choose-file-dialog :button-string
  106.                                                      "Clean")))))
  107.     (dolist (file (append (directory (merge-pathnames dir ".*~"))
  108.                           (directory (merge-pathnames dir "**~"))))
  109.       (format t "Deleting ~S~%" file)
  110.       (delete-file file)))
  111.   (princ "All clean!")
  112.   (values))
  113.  
  114.  
  115. ;;; make sure we're not clobbering any after methods that have already
  116. ;;; been defined elsewhere
  117. (when (or (not (find-method #'window-save '(:after) (list (find-class 'fred-window)) nil))
  118.           (and (progn (warn "another AFTER method for WINDOW-SAVE is defined.")
  119.                       (ed-beep) (ed-beep) t)
  120.                (y-or-n-p "Clobber existing AFTER method and install autosave~%~
  121.                           cleanup feature?")))
  122.  
  123.   ;;; delete the autosave file when saving the original one
  124.   ;;; also known as autocleanup
  125.   
  126.   (defmethod window-save :after ((w fred-window))
  127.     (let  ((autosave-file (pathname (concatenate 'string 
  128.                                                  (namestring (slot-value w 'my-file-name))
  129.                                                  "~"))))
  130.       (if (probe-file autosave-file)
  131.         (delete-file autosave-file)))))
  132.   
  133. ;;; make sure we're not clobbering any after methods that have already
  134. ;;; been defined elsewhere
  135. (when (or (not (find-method #'initialize-instance '(:around) (list (find-class 'fred-window)) nil))
  136.           (and (progn (warn "another AROUND method for INITIALIZE-INSTANCE for FRED-WINDOW~%~
  137.                              is defined.") (ed-beep) (ed-beep) t)
  138.                (y-or-n-p "Clobber existing AROUND method and install check for~%~
  139.                           newer autosave file?")))
  140.   
  141.   ;; check for newer autosave file when opening and prompt if find one.
  142.   (defmethod initialize-instance :around ((w fred-window) &rest initargs)
  143.     (cond
  144.      ;; only worry when there's a filename attached
  145.      ((getf initargs :filename)
  146.       (let* ((filename (getf initargs :filename))
  147.              (autosave-file (pathname (concatenate 'string (namestring filename) "~"))))
  148.         (if (and filename
  149.                  (probe-file autosave-file)
  150.                  (> (file-write-date autosave-file)
  151.                     (file-write-date filename))
  152.                  (y-or-n-dialog "An autosave file with a more recent write-date exists for this file.  Do you wish to open that file instead?"))
  153.           (apply #'call-next-method w (append (list :filename autosave-file) initargs))
  154.           (call-next-method))))
  155.      (t (call-next-method)))))
  156.     
  157.